home *** CD-ROM | disk | FTP | other *** search
/ Over 1,000 Windows 95 Programs / Over 1000 Windows 95 Programs (Microforum) (Disc 1).iso / 1261 / samples / conway.spl < prev    next >
Encoding:
Text File  |  1996-04-01  |  15.7 KB  |  439 lines
  1.  /* Generated by EasyCODE(SPX) V6.0 at 02.04.1996 14:19:21
  2.     with C:\EASY\SPL4.CFG */
  3.  
  4.  /* CONWAY - Game */
  5.  
  6.  CONWAY_GAME:    PROC   OPTIONS (MAIN);
  7.  /* Declarations */
  8.     DCL  ITS_CONVNCH               ENTRY (FIXED(31) BINARY, CHAR(11));
  9.  
  10.     DCL  PRINTC                    ENTRY (CHAR (*), INTEGER);
  11.     DCL  READC                     ENTRY (CHAR (*), INTEGER, BIT (1));
  12.  
  13.  
  14.     DCL  (I,  J)                   INTEGER;
  15.     DCL  STEPNUMBER                INTEGER(31);
  16.     DCL  STEPNUMBER_VALID          BIT  (1)  INIT('0'B);
  17.     DCL  NUMBER_OUTPUTS            INTEGER(31);
  18.     DCL  NUMBER_OUTPUTS_VALID      BIT  (1)  INIT('0'B);
  19.     DCL  NEW_FIGURE_DESIRED        BIT  (1)  INIT('1'B);
  20.  
  21.     DCL  (OUTPUT, GAMESTEP)  ENTRY INTERNAL;
  22.  /* Subprocedures and function procedures */
  23.     /* USER_WANTS_AGAIN */
  24.        USER_WANTS_AGAIN: PROC    RETURNS (BIT(1));
  25.        DCL  USER_RESPONSE               CHAR;
  26.        DCL  READ_OK                       BIT (1);
  27.        DO WHILE ('1'B);
  28.           CALL  PRINTC ('ENTER: S,C,G,O,A OR ?', 30);
  29.           READ_OK = '1'B;
  30.           CALL  READC (USER_RESPONSE, 1, READ_OK);
  31.           IF NOT (READ_OK)
  32.           THEN DO;
  33.              GOTO READ_ERROR;
  34.           END;
  35.           DO CASE USER_RESPONSE;
  36.              WHEN ('S') DO;
  37.                 RETURN ('0'B);
  38.              END;
  39.              WHEN ('C') DO;
  40.                 RETURN ('1'B);
  41.              END;
  42.              WHEN ('G') DO;
  43.                 STEPNUMBER_VALID = '0'B;
  44.                 RETURN ('1'B);
  45.              END;
  46.              WHEN ('O') DO;
  47.                 STEPNUMBER_VALID = '0'B;
  48.                 NUMBER_OUTPUTS_VALID = '0'B;
  49.                 RETURN ('1'B);
  50.              END;
  51.              WHEN ('A') DO;
  52.                 NEW_FIGURE_DESIRED   = '1'B;
  53.                 STEPNUMBER_VALID     = '0'B;
  54.                 NUMBER_OUTPUTS_VALID = '0'B;
  55.                 RETURN ('1'B);
  56.              END;
  57.              WHEN ('?') DO;
  58.                 CALL  PRINTC ('S = STOP', 11);
  59.                 CALL  PRINTC ('C = CONTINUE WITHOUT CHANGES', 34);
  60.                 CALL  PRINTC ('G = CHANGE NUMBER OF GAMESTEPS '
  61.                        CAT 'BETWEEN TWO OUTPUTS'
  62.                        CAT ', THEN CONTINUE', 72);
  63.                 CALL  PRINTC ('O = CHANGE NUMBER OF OUTPUTS '
  64.                        CAT 'UNTIL NEXT INPUT '
  65.                        CAT 'AND NUMBER OF GAMESTEPS '
  66.                        CAT 'BETWEEN OUTPUTS'
  67.                        CAT ', THEN CONTINUE',  114);
  68.                 CALL  PRINTC ('A = START AGAIN', 19);
  69.              END;
  70.              OTHERS DO;
  71.              END;
  72.           END;
  73.        END;
  74.        RETURN ('0'B);
  75.        END; /* End Function */
  76.  
  77.     /* NUMVALUE */
  78.        NUMVALUE: PROC (INPUT_STRING)   RETURNS (INTEGER(31));
  79.        DCL  INPUT_STRING               CHAR(11);
  80.  
  81.  
  82.        DCL  (START_ADDR,
  83.              END_ADDR)                 POINTER;
  84.        DCL  START_CHARACTER            CHAR    BASED (START_ADDR);
  85.        DCL  END_CHARACTER              CHAR    BASED (END_ADDR);
  86.        DCL  RESULT                     INTEGER(31);
  87.        DCL  1  CHAR_DESCRIPTION        MODEL,
  88.                2 REPRESENTS_FIGURE     BIT(1),
  89.                2 VALUE_OF_FIGURE       INTEGER;
  90.        DCL  CH_DESCR                   MODE (CHAR_DESCRIPTION);
  91.  
  92.        DCL  DESCRIBE_CHAR              ENTRY (CHAR)
  93.             RETURNS (MODE (CHAR_DESCRIPTION))
  94.             INTERNAL;
  95.        /* DESCRIBE_CHAR */
  96.           DESCRIBE_CHAR: PROC    (CHAR_IN)
  97.                            RETURNS (MODE (CHAR_DESCRIPTION));
  98.           DCL  CHAR_IN          CHAR;
  99.           DCL  1  CHAR_IN_STRUC DEF CHAR_IN,
  100.                  2 HALFBYTE_1   BIT (4)     UNAL,
  101.                  2 HALFBYTE_2   INTEGER (4) UNAL;
  102.           DCL  DESCRIPTION      MODE (CHAR_DESCRIPTION);
  103.           IF     (CHAR_IN_STRUC.HALFBYTE_1 = 'F'X)
  104.              AND (CHAR_IN_STRUC.HALFBYTE_2 < 10)
  105.           THEN DO;
  106.              DESCRIPTION.REPRESENTS_FIGURE = '1'B;
  107.              DESCRIPTION.VALUE_OF_FIGURE = CHAR_IN_STRUC.HALFBYTE_2;
  108.           END;
  109.           ELSE DO;
  110.              DESCRIPTION.REPRESENTS_FIGURE = '1'B;
  111.           END;
  112.           RETURN (DESCRIPTION);
  113.           END; /* End Function */
  114.  
  115.        RESULT = 0;
  116.        SEARCH_BEGIN:
  117.           DO START_ADDR = ADDR(INPUT_STRING)
  118.               TO ADDR(INPUT_STRING) + 10;
  119.              IF START_CHARACTER NE ' '
  120.              THEN DO;
  121.                 CH_DESCR = DESCRIBE_CHAR (START_CHARACTER);
  122.                 IF CH_DESCR.REPRESENTS_FIGURE
  123.                 THEN DO;
  124.                    BREAK SEARCH_BEGIN;
  125.                 END;
  126.                 ELSE DO;
  127.                    RETURN (0);
  128.                 END;
  129.              END;
  130.           END;
  131.         
  132.        SEARCH_END
  133.           DO END_ADDR = ADDR(INPUT_STRING) + 10 BY (-1) TO START_ADDR;
  134.              IF END_CHARACTER NE ' '
  135.              THEN DO;
  136.                 CH_DESCR = DESCRIBE_CHAR (END_CHARACTER);
  137.                 IF CH_DESCR.REPRESENTS_FIGURE
  138.                 THEN DO;
  139.                    BREAK SEARCH_END;
  140.                 END;
  141.                 ELSE DO;
  142.                    RETURN (0);
  143.                 END;
  144.              END;
  145.           END;
  146.         
  147.        /* GETVALUE */
  148.        DO START_ADDR = START_ADDR TO END_ADDR;
  149.           CH_DESCR = DESCRIBE_CHAR (START_CHARACTER);
  150.           IF CH_DESCR.REPRESENTS_FIGURE
  151.           THEN DO;
  152.              RESULT = RESULT * 10 + CH_DESCR.VALUE_OF_FIGURE;
  153.           END;
  154.           ELSE DO;
  155.              RETURN (0);
  156.           END;
  157.        END;
  158.        RETURN (RESULT); 
  159.        END; /* End Function */
  160.  
  161.     /* NEW_NUMBER */
  162.        NEW_NUMBER: PROC    (TEXT, TEXT_LENGTH, NUMBER);
  163.        DCL  TEXT_LENGTH INTEGER;
  164.        DCL  TEXT        CHAR (TEXT_LENGTH);
  165.        DCL  NUMBER      INTEGER (31);
  166.        DCL  NUMBER_CH   CHAR (11);
  167.        DCL  READ_OK     BIT (1);
  168.        CALL  PRINTC (TEXT, TEXT_LENGTH);
  169.        READ_OK = '1'B;
  170.        DO WHILE ('1'B);
  171.           CALL  READC (NUMBER_CH, 11, READ_OK);
  172.           IF READ_OK
  173.           THEN DO;
  174.              NUMBER = NUMVALUE (NUMBER_CH);
  175.              IF NUMBER = 0
  176.              THEN DO;
  177.                 CALL  PRINTC
  178.                        ('INVALID NUMBER. REENTER.',
  179.                         36);
  180.              END;
  181.           END;
  182.           ELSE DO;
  183.              GOTO READ_ERROR;
  184.           END;
  185.           IF NOT (NUMBER = 0)
  186.              THEN BREAK;
  187.        END;
  188.        END; /* End Procedure */
  189.  
  190.     /* SET_START_FIGURE */
  191.        SET_START_FIGURE: PROC    RECURSIVE;
  192.        DCL  MAX_NUMLINES     INTEGER(31) CONSTANT (20);
  193.        DCL  MAX_NUMCOLUMNS   INTEGER(31) CONSTANT (76);
  194.  
  195.        DCL  (NUMCOLUMNS,
  196.              NUMCOLS3,
  197.              NUMCOLS4,
  198.              NUMLINES)       INTEGER(31) STATIC;
  199.        DCL  (WORK1,
  200.              WORK2)     CHAR   ((MAX_NUMLINES + 2) *
  201.                                 (MAX_NUMCOLUMNS + 4)) STATIC;
  202.        DCL  LINE_NR          INTEGER (31);
  203.        DCL  (FIELD1_LINE_ADDR,
  204.              FIELD2_LINE_ADDR) (0 : MAX_NUMLINES + 1) PTR STATIC;
  205.        DCL  BASE_LINE_ADDR   PTR;
  206.        DCL  LINE_ADDR          (0 : MAX_NUMLINES + 1) PTR
  207.                                BASED (BASE_LINE_ADDR);
  208.        DCL  NUM_CH             CHAR (11);
  209.        DCL  1  NUMCH_STRUC     DEFINED NUM_CH,
  210.               2 BEGIN          CHAR (9),
  211.               2 END_2          CHAR (2);
  212.               
  213.        DCL  (HELPPOINTER1,
  214.              HELPPOINTER2)     PTR;
  215.        DCL  CH2_BASED          CHAR (2) BASED  (HELPPOINTER1);
  216.        DCL  CH2                CHAR (2);
  217.        DCL  READ_OK            BIT (1);
  218.        DCL  LINE               CHAR (NUMCOLS4) BASED  (HELPPOINTER1);
  219.        DCL  1  LINE_STRUCTURE  BASED  (HELPPOINTER1),
  220.               2  INVISIBLE     CHAR (1),
  221.               2  VISIBLE       CHAR (NUMCOLS3);
  222.        DCL  CH_BASED           CHAR BASED  (HELPPOINTER1);
  223.        DCL  LINE_CHANGED       BIT (1);
  224.        /* COMPUTE_LINE */
  225.           COMPUTE_LINE: PROC     (DESTLINE_ADDR,
  226.                                   SOURCELINE1_ADDR,
  227.                                   SOURCELINE2_ADDR,
  228.                                   SOURCELINE3_ADDR,
  229.                                   NUMCOLUMNS);
  230.           DCL  (DESTLINE_ADDR,
  231.                 SOURCELINE1_ADDR,
  232.                 SOURCELINE2_ADDR,
  233.                 SOURCELINE3_ADDR) PTR;
  234.           DCL  NUMCOLUMNS         INTEGER;
  235.           DCL  NUMBER_NEIGHBOURS  INTEGER(8);
  236.           DCL  COLUMN             INTEGER;
  237.           DCL  DEST        (0 : NUMCOLUMNS) CHAR
  238.                BASED (DESTLINE_ADDR);
  239.           DCL  SOURCELINE1 (0 : NUMCOLUMNS) CHAR
  240.                BASED (SOURCELINE1_ADDR);
  241.           DCL  SOURCELINE2 (0 : NUMCOLUMNS)
  242.                CHAR    BASED (SOURCELINE2_ADDR);
  243.           DCL  SOURCELINE3 (0 : NUMCOLUMNS) CHAR
  244.                BASED (SOURCELINE3_ADDR);
  245.           DO COLUMN = 1 TO NUMCOLUMNS;
  246.              NUMBER_NEIGHBOURS =
  247.                             (SOURCELINE1  (COLUMN - 1)  = 'X')
  248.                           + (SOURCELINE1  (COLUMN)      = 'X')
  249.                           + (SOURCELINE1  (COLUMN + 1)  = 'X')
  250.                           + (SOURCELINE2  (COLUMN - 1)  = 'X')
  251.                           + (SOURCELINE2  (COLUMN + 1)  = 'X')
  252.                           + (SOURCELINE3  (COLUMN - 1)  = 'X')
  253.                           + (SOURCELINE3  (COLUMN)      = 'X')
  254.                           + (SOURCELINE3  (COLUMN + 1)  = 'X');
  255.              DO CASE NUMBER_NEIGHBOURS;
  256.                 WHEN (0, 1) DO;
  257.                    /* ISOLATION */
  258.                    DEST (COLUMN) = ' ';
  259.                 END;
  260.                 WHEN (2) DO;
  261.                    /* SURVIVE */
  262.                    DEST (COLUMN) = SOURCELINE2 (COLUMN);
  263.                 END;
  264.                 WHEN (3) DO;
  265.                    /* BIRTH */
  266.                    DEST (COLUMN) = 'X';
  267.                 END;
  268.                 OTHERS DO;
  269.                    /* OVERPOPULATION */
  270.                    DEST (COLUMN) = ' ';
  271.                 END;
  272.              END;
  273.           END;
  274.           RETURN;
  275.           END; /* End Procedure */
  276.  
  277.        DO WHILE ('1'B);
  278.           CALL  NEW_NUMBER ('LENGTH OF A LINE ?', 21, NUMCOLUMNS);
  279.           IF NUMCOLUMNS <= MAX_NUMCOLUMNS
  280.              THEN BREAK;
  281.           CALL  ITS_CONVNCH (MAX_NUMCOLUMNS, NUM_CH);
  282.           CALL  PRINTC (NUMCH_STRUC.END_2 ||
  283.                  ' = MAXIMUM NUMBER OF COLUMNS IN THIS VERSION', 45);
  284.        END;
  285.        DO WHILE ('1'B);
  286.           CALL  NEW_NUMBER ('NUMBER OF LINES ?', 17, NUMCOLUMNS);
  287.           IF NOT (NUMLINES > MAX_NUMLINES)
  288.              THEN BREAK;
  289.           CALL  ITS_CONVNCH (MAX_NUMLINES, NUM_CH);
  290.           CALL  PRINTC (NUMCH_STRUC.END_2 ||
  291.                  ' = MAXIMUM NUMBER OF LINES IN THIS VERSION', 42);
  292.        END;
  293.        /* Initializations */
  294.           NUMCOLS3 = NUMCOLUMNS + 3;
  295.           NUMCOLS4 = NUMCOLS3  + 1;
  296.  
  297.           WORK1,
  298.           WORK2  = ' ';
  299.  
  300.           HELPPOINTER1  =  ADDR (WORK1);
  301.           HELPPOINTER2  =  ADDR (WORK2);
  302.           LINE_NR     =  0;
  303.           DO WHILE (LINE_NR <= NUMLINES + 1);
  304.              FIELD1_LINE_ADDR (LINE_NR)  =  HELPPOINTER1;
  305.              FIELD2_LINE_ADDR (LINE_NR)  =  HELPPOINTER2;
  306.              CALL  ITS_CONVNCH (LINE_NR, NUM_CH);
  307.              (HELPPOINTER1 + NUMCOLUMNS + 2) -> CH2_BASED
  308.               = NUMCH_STRUC.END_2;
  309.              (HELPPOINTER2 + NUMCOLUMNS + 2) -> CH2_BASED
  310.               = NUMCH_STRUC.END_2;
  311.              HELPPOINTER1 = HELPPOINTER1 + NUMCOLS3;
  312.              HELPPOINTER2 = HELPPOINTER2 + NUMCOLS3;
  313.              LINE_NR = LINE_NR + 1;
  314.           END;
  315.           GLOBAL1 = ADDR (FIELD1_LINE_ADDR);
  316.           GLOBAL2 = ADDR (FIELD2_LINE_ADDR);
  317.        DO WHILE ('1'B);
  318.           CALL  OUTPUT;
  319.           /* Change line */
  320.              LINE_CHANGED = '0'B;
  321.              DO WHILE ('1'B);
  322.                 READ_OK = '1'B;
  323.                 LINE_CHANGED = '0'B;
  324.                 CALL  PRINTC ('NUMBER OF LINE TO CHANGE '
  325.                        CAT '(2 DIGITS) OR 00', 51);
  326.                 CALL  READC (CH2,2 , READ_OK);
  327.                 IF      NOT (READ_OK)
  328.                 THEN DO;
  329.                    GOTO READ_ERROR;
  330.                 END;
  331.                 ELSE IF CH2 NE '00'
  332.                 THEN DO;
  333.                    NUMCH_STRUC.BEGIN = ' ';
  334.                    NUMCH_STRUC.END_2 = CH2;
  335.                    LINE_NR = NUMVALUE (NUM_CH);
  336.                    IF LINE_NR > NUMLINES
  337.                    THEN DO;
  338.                       CALL  PRINTC ('LINE NUMBER TOO HIGH', 21);
  339.                    END;
  340.                    ELSE DO;
  341.                       /* Line number ok */
  342.                          HELPPOINTER1
  343.                           = FIELD1_LINE_ADDR (LINE_NR) + 1;
  344.                          READ_OK = '1'B;
  345.                          CALL  READC (LINE, NUMCOLUMNS, READ_OK);
  346.                          IF NOT (READ_OK)
  347.                          THEN DO;
  348.                             GOTO READ_ERROR;
  349.                          END;
  350.                          ELSE DO;
  351.                             /* If not 'X' used for marking: */
  352.                             HELPPOINTER2
  353.                              = HELPPOINTER1 + NUMCOLUMNS;
  354.                             DO WHILE (HELPPOINTER1 < HELPPOINTER2);
  355.                                IF CH_BASED NE ' '
  356.                                THEN DO;
  357.                                   CH_BASED = 'X';
  358.                                END;
  359.                                HELPPOINTER1 = HELPPOINTER1 + 1;
  360.                             END;
  361.                             LINE_CHANGED = '1'B;
  362.                          END;
  363.                    END;
  364.                 END;
  365.                 ELSE DO;
  366.                    RETURN;
  367.                 END;
  368.                 IF LINE_CHANGED
  369.                    THEN BREAK;
  370.              END;
  371.        END;
  372.        RETURN;
  373.        /* OUTPUT */
  374.           OUTPUT: ENTRY;
  375.              CALL  PRINTC (' ', 1);
  376.              DO LINE_NR = 1 TO NUMLINES;
  377.                 CALL  PRINTC (GLOBAL1 -> LINE_ADDR (LINE_NR) ->
  378.                               LINE_STRUCTUR.VISIBLE,
  379.                                   NUMCOLS3);
  380.              END;
  381.           RETURN;
  382.        /* GAMESTEP */
  383.           GAMESTEP: ENTRY;
  384.              LINE_NR = 1;
  385.              DO WHILE ((LINE_NR <= NUMLINES));
  386.                 CALL COMPUTE_LINE
  387.                       (GLOBAL2 -> LINE_ADDR (LINE_NR),
  388.                        GLOBAL1 -> LINE_ADDR (LINE_NR - 1),
  389.                        GLOBAL1 -> LINE_ADDR (LINE_NR),
  390.                        GLOBAL1 -> LINE_ADDR (LINE_NR + 1),
  391.                        NUMCOLUMNS);
  392.                 LINE_NR = LINE_NR + 1;
  393.              END;
  394.              EXCHANGE_SOURCE_AND_DEST:
  395.                 HELPPOINTER1 = GLOBAL1;
  396.                 GLOBAL1      = GLOBAL2;
  397.                 GLOBAL2      = HELPPOINTER1;
  398.               
  399.           RETURN;
  400.        END; /* End Procedure */
  401.  
  402.  /* Implementation */
  403.     DO WHILE (USER_WANTS_AGAIN ());
  404.        IF NEW_FIGURE_DESIRED
  405.        THEN DO;
  406.           CALL SET_START_FIGURE;
  407.           NEW_FIGURE_DESIRED = '0'B;
  408.        END;
  409.        IF NOT (NUMBER_OUTPUTS_VALID)
  410.        THEN DO;
  411.           CALL  NEW_NUMBER ('NUMBER OF OUTPUTS UNTIL '
  412.                  CAT 'NEXT INPUT', 42,
  413.                                NUMBER_OUTPUTS);
  414.           NUMBER_OUTPUTS_VALID = '1'B;
  415.        END;
  416.        IF NOT (STEPNUMBER_VALID)
  417.        THEN DO;
  418.           CALL  NEW_NUMBER ('NUMBER OF STEPS BETWEEN TWO OUTPUTS ', 38,
  419.                                STEPNUMBER);
  420.           STEPNUMBER_VALID = '1'B;
  421.        END;
  422.        DO I = 1 TO NUMBER_OUTPUTS;
  423.           DO J = 1 TO STEPNUMBER;
  424.              CALL  GAMESTEP;
  425.           END;
  426.           CALL  OUTPUT;
  427.        END;
  428.     END;
  429.     
  430.     RETURN; /* Normal end of program */
  431.      
  432.     READ_ERROR:
  433.        CALL  PRINTC ('READ ERROR!', 11);
  434.        /*1 CALL PRINTC ('SYSDTA NoT (PRIMARY)?', 23); */
  435.        RETURN; /* TERMINATION DUE TO READ ERROR */
  436.      
  437.  END; /* End Procedure */
  438.  
  439.